perm filename SCX.F4[1,MUS] blob
sn#078078 filedate 1973-12-18 generic text, type T, neo UTF8
00010 C SUBRS. SCMSS, TYPE
00020
00100 SUBROUTINE SCMSS
00200 DATA ISEMI/';'/
00300 COMMON/SCM/V(78),I,LCNT,STAFF,JLIST(200),REND
00350 C JLIST WILL SOMETIMES BE USED(WIPED OUT) FOR R(X,Y) OVERFLOW(>50 ITEMS.)
00500 DIMENSION RLIST(200),NOMOR(6),WARN(6),R(8,100)
00600 COMMON/SCX/RHY(4),JALPHA(12),RB,RC,JZ,IRHY,JD,KA,KB,IZ
00610 1/STF/RSTFAC(8),RSTJC/FRMT/F78F(1),FA1(1),FA5(1),IREAD
00700 1/XRN/RN(4000) /ALF/INP(72),ML /SC/J,L,MK
00900 1,ISKP,XMINUS,N,IEXP,LK,NNUM,JJ,JA,DBST,NFLG,IXX,ISEMI,JG
01000 1 ,VX(50),IAMP,K,KN,M,MODE,IBLA
01100 EQUIVALENCE (VX1,VX(1)),(INP1,INP(1)),(VX2,VX(2)),(VX3,VX(3))
01200 1,(VX4,VX(4)),(VX5,VX(5)),(JLIST,RLIST),(R1,R,RN(3001))
01300 1 ,(INP2,INP(2)),(INP3,INP(3)),(INP4,INP(4))
01500 DATA IBLA/' '/,KSLA/'/'/,IXX/'X'/,LCNT/1/
01600 1,RHY/.5,.25,.125,.0625/,JALPHA/',','-','.','=','(',')','+',
01650 1 '*',':',';','"',' '/
01700 IF(R1.EQ.16.)GO TO 16
01800 C FOR LETTERS
01900 IF(R1.NE.14.AND.R1.NE.144)GO TO 11
02000 MODE=1
02100 IBEAM=-1
02200 IZ=0
02300 IREAD=0
02400 11 IF(MODE)GO TO 111
02500 IF(R1.NE.144.)GO TO (1,2,3,4,5,8024)MODE
02600 2302 TYPE 80053
02700 IF(IREAD.EQ.0)TYPE 80051
02800 ACCEPT 80052,STAFF,L
02850 IF(STAFF.GE.99)GO TO 8027
02875 C TYPE 99 OR 999 TO ESCAPE WHEN IN READ-IN MODE
02900 IF(IREAD.EQ.1)GO TO 80041
02950 IF(LOOK(L).EQ.0)GO TO 2302
03000 IREAD=1
03100 REWIND 22
03200 CALL IFILE(22,L)
03300 2301 READ(22,21141,END=8027),L,INP
03400 IF(MODE.EQ.6)GO TO 1111
03500 IF(INP1.EQ.IBLA)GO TO 8006
03600 GO TO 80041
03700 1111 MODE=-1
03800 R(2,IZ+1)=-1.
03900 REND=1.0
04000 GO TO 8026
04200 C ABOVE ALLOWS MORE STAVES TO BE READ
04300
04400 111 IZ=0
04500 MODE=1
04600 GO TO 2302
04700 C WILL READ ANOTHER STAFF
04800 80053 FORMAT(' TYPE STAFF NUM. '$)
04900 80051 FORMAT('+AND FILE NAME'/)
05000 80052 FORMAT(F,A5)
05100
05200 2 TYPE 8008,IRHY
05300 CC GO TO 80042
05350 GO TO 1
05400 3 TYPE 8002
05500 330 ACCEPT 2114,N,L,INP3,INP4
05600 IF(N.EQ.'G')GO TO 8024
05700 C TYPE 'GO' TO PASS LATER ITEMS
05800 IF(N.EQ.'9'.OR.N.EQ.'B')GO TO 99
05900 IF(N.EQ.'Y')GO TO 1
05950 IF(N.NE.'N'.AND.N.NE.' ')GO TO 11
05975 C PICKS UP TYPOS
06000 2000 MODE=MODE+1
06100 GO TO 11
06200 4 TYPE 8023
06300 GO TO 330
06400 5 TYPE 8022
06500 GO TO 330
06600 8024 REND=-1.
06610 CALL HYDPOG(3)
06655 C ERASES NOTE NUMBERS
06700 IF(IBEAM)GO TO 8006
06800 C JUMP IF NO STEM NORMALIZATION NEEDED
06900 C IF(MODE.LT.3)GO TO 8006
07000 IZ=IZ+1
07100 R(1,IZ)=19.
07200 R(2,IZ)=STAFF
07300 C ADJUSTS NOTE STEMS, ETC.
07400 8006 MODE=MODE+1
07500 IF(IREAD.EQ.1)GO TO 2301
07600 8026 R(1,IZ+1)=100.
07700 IF(IREAD.EQ.2)REND=1.
07750 273 IF(IREAD.NE.1)INP(2)=0
07775 C WHY =0 ABOVE?????
07800 RETURN
07900
08300
08400 8027 IREAD=2
08500 STAFF=99.
08600 C STEMS ON ALL STAVES WILL NORMALIZE
08700 GO TO 8024
08800 C READER IS NOW FINISHED
08900
09000 99 IF(INP3.EQ.'9')GO TO 999
09200 C ELSE GET ANOTHER CHANCE TO SAY 'NO'
09300 C 99=BACKUP, 999=ESCAPE
09400 MODE=MODE-1
09600 IF(MODE.GE.1)GO TO 11
10100 999 DO 2222 K=1,IZ
10200 2222 R(1,K)=99.
10400 9999 REND=100
10500 GO TO 8026
10600
10800 8008 FORMAT(' TYPE ',I2,' RHYTHMS')
10900 8002 FORMAT(' ADD BEAMS?'/)
11000 8022 FORMAT(' ADD SLURS?'/)
11100 8023 FORMAT(' ADD MARKS?'/)
11200 8011 FORMAT(1XI3,' MORE RHYTHMS NEEDED'/)
11210 8015 K=IRHY-I+1
11400 TYPE 8011,K
11500 IF(IREAD.EQ.0)GO TO 11
11600 IZ=0
11700 IREAD=0
11800 MODE=5
11900 GO TO 8024
12000
12100 6 MODE=5
12200 IF(IREAD.NE.0)GO TO 8006
12300 CC1 TYPE 8005
12400 1 CALL TYPE
12500 CC80042 ACCEPT 2114,INP
12600 IF(INP1.EQ.IBLA) GO TO 1
12700 IF(INP1.EQ.'9'.AND.INP2.EQ.'9')GO TO 99
12800 C TYPE '99' TO BACK-UP
12900 80041 IF(MODE.GE.3)GO TO 133
13100 RETRO=-1.
13200 I=1
13300 PARENS=0
13400 MOT=0
13500 JZ=1
13600 IAMP=0
13700 C IAMP IS 'BLANK LINE'FLAG ON PP1-3.
13800 KL=0
13900 RA=0
14000 2408 MLX=1
14100 L=-1
14200 DO 2999 K=1,72
14300 N=INP(K)
14400 IF(N.EQ.IBLA)GO TO 2999
14500 L=0
14600 IF(N.NE.'*'.AND.N.NE.ISEMI)GO TO 2999
14700 C READS 72 CHARS. INCLUDING *.
14800 INP(K+1)=ISEMI
14900 GO TO 1773
15000 C --- X/Y/Z* --- WITH NO SEMICOLON WORKS FOR THIS PROG. ONLY!
15100 2999 CONTINUE
15200 IF(IREAD.EQ.1)GO TO 8015
15300 GO TO 273
15400 C ERROR IF NO '*' OR ';' AT END OF LINE.
15500
15600 1299 IF(JZ.NE.0)GO TO 1773
15700 7773 IF(IREAD.EQ.0)GO TO 77731
15800 C BYPASS IF NOT USING EDIT FILE
15900 READ(22,21141),L,INP
16000 C TO READ 2ND LINE OF NOTE INPUT, IF NEEDED
16100 GO TO 77732
16200 CC77731 TYPE 8005
16300 CC ACCEPT 2114,INP
16350 77731 CALL TYPE
16400 IF(INP1.EQ.IBLA)GO TO 7773
16500 77732 JM=-1
16600 JZ=0
16700 GO TO 2408
16800 C 'LISTS' MUST END WITH *
16900 1773 JZ=0
17000 DBST=1.
17100 17731 ML=MLX
17200 IF(PARENS.LE.0.)GO TO 975
17300 C PARENS=-1, OPENS; =1, CLOSES; =0, NONE
17400 3362 PARENS=0
17500 MOT=I-LMOT
17600 IF(LCNT+MOT.LT.198)GO TO 33621
17700 DATA NOMOR/30H(' NO ROOM FOR MOTIVE ',A1/) /
17800 TYPE NOMOR,JMOT
17900 GO TO 1
18000 33621 JLIST(LCNT+1)=MOT
18100 LCNT=LCNT+2
18200 DO 2140 JG=0,MOT-1
18300 2140 RLIST(LCNT+JG)=V(LMOT+JG)
18400 LCNT=LCNT+MOT
18500 IF(IAMP)GO TO 3013
18700 C FOR CLOSE PARENS ON LAST ITEM
18800 C STORE MOTIVE IN RLIST ARRAY
18900
19000 975 DO 236 JDD=ML,72
19100 JD=JDD
19200 N=INP(JD)
19300 C ((((())))) MAY 13,71 /Z (D4/E/X 2 3/) CS/ ETC. CAN USE 26 LABELS.
19400 IF(N.NE.'('.AND.N.NE.')'.AND.N.NE.':')GO TO 2361
19500 INP(JD)=IBLA
19600 IF(N.NE.':')GO TO 1113
19700 DBST=-1.
19800 GO TO 236
19900 C FOR 'DOUBLE STOPS'
20000 1113 L=JD-1
20100 5113 IF(INP(L).NE.IBLA)GO TO 2113
20200 L=L-1
20300 GO TO 5113
20400 2113 IF(N.EQ.')')GO TO 3361
20500 C ONLY ONE () AS YET, NO NESTING
20600 1140 JMOT=INP(L)
20700 C MOTIVE NAME
20800 DO 11401 JC=1,LCNT-1
20900 IF(JMOT.NE.JLIST(JC))GO TO 11401
21000 C FINDS DUPLICATE IDENTIFIER
21200 11402 FORMAT(' MOTIVIC (',A1,') USED TWICE')
21300 CC GO TO 1
21400 C FOR BACKUP
21500 11401 CONTINUE
21600 JLIST(LCNT)=JMOT
21700 PARENS=-1.
21800 C A PARENTH IS OPEN
21900 INP(L)=IBLA
22000 LMOT=I
22100 C LMOT IS CURRENT POINT IN V ARRAY
22200 GO TO 236
22300 3361 IF(PARENS.NE.0)GO TO 33612
22400 DATA WARN/30H(' PARENTH ERROR - GOING ON'/)/
22500 TYPE WARN
22600 33611 INP(JD)=IBLA
22700 GO TO 236
22800 33612 PARENS=1.
22900 C SETS PARENS CLOSED FLAG
23000 GO TO 33611
23100 C NO INVERSIONS POSSIBLE NOW
23200 2361 IF(N.NE.'@')GO TO 5361
23300 DO 113 L=1,72
23400 K=JD+L
23500 C K IS USED AT 240!!!
23600 JG=INP(K)
23700 IF(JG.NE.'-')GO TO 7113
23800 RETRO=0
23900 INP(K)=IBLA
24000 GO TO 113
24100 7113 IF(JG.NE.IBLA)GO TO 4113
24200 113 CONTINUE
24300 4113 DO 6361 L=1,LCNT
24400 IF(JG.NE.JLIST(L))GO TO 6361
24500 VX1=0
24600 DO 40 M=JD+2,72
24700 JG=INP(M)
24800 IF(JG.EQ.IBLA)GO TO 40
24900 IF(JG.EQ.KSLA.OR.JG.EQ.ISEMI.OR.JG.EQ.'*')GO TO 140
25000 ML=M
25100 GO TO 240
25200 40 CONTINUE
25300 240 JC=JM
25400 JM=-1
25500 INP(K)=IBLA
25600 JA=0
25700 C MUST BE ZERO IN SCANR
25800 CALL SCANR
25900 JM=JC
26000 140 JC=1
26100 KN=L+2
26210 M=KN+JLIST(L+1)
26300 IF(RETRO)GO TO 940
26400 KN=M-1
26550 M=L+1
26600 JC=-1
26700 RETRO=-1.
26800
26900 940 Z=RLIST(KN)
27000 IF(VX1.EQ.0)GO TO 540
27100 C " @Q N " WHERE N= 1/2 STEPS IN 'NOTES' OR MULT FACTOR IN OTHERS.
27200 IF(MODE.EQ.1)GO TO 440
27300 C MODE 1 IS NOTES, 2 IS RHY.
27400 V(I)=Z*VX1
27500 GO TO 7361
27600 440 IF(Z.EQ.85.)GO TO 540
27700 V(I)=Z+VX1
27800 GO TO 7361
27900 540 V(I)=Z
28000 7361 I=I+1
28100 KN=KN+JC
28200 IF(KN.NE.M)GO TO 940
28300
28400 RB=V(I-1)
28600 DO 8361 L=JD,72
28700 JG=INP(L)
28800 INP(L)=IBLA
28900 IF(JG.EQ.KSLA)GO TO 9361
29000 IF(JG.EQ.ISEMI)GO TO 93611
29200 8361 IF(JG.EQ.'*')IAMP=-1
29300 9361 MLX=L
29400 IF(IAMP.EQ.0)GO TO 17731
29600 JZ=-1
29700 93611 IF(IAMP)GO TO 3013
29900 GO TO 7773
30000 6361 CONTINUE
30100 TYPE 6362,JG
30200 GO TO 11402
30300 6362 FORMAT(' MOTIVIC (',A1,') NOT FOUND')
30400 C @@@@@@@@@@@@@@@@@@@@@@@@@@
30500 5361 IF(N.NE.KSLA)GO TO 636
30600 MLX=JD+1
30700 JZ=-1
30800 INP(JD)=ISEMI
30900 436 IF(INP(MLX).NE.IBLA)GO TO 103
31000 MLX=MLX+1
31100 GO TO 436
31200 636 IF(N.EQ.ISEMI)GO TO 103
31300 936 IF(N.NE.'.')GO TO 736
31400 L=INP(JD+1)
31500 KL=NALF(L)
31600 IF(L.GT.0.AND.KL.GE.0.AND.KL.LE.9)GO TO 236
31700 C JUMP IF IT'S A NUMBER
31800 IF(MODE.EQ.2)INP(JD)=1
31900 C :::::::::******* ↑↑↑↑ MODE #?
32000 GO TO 236
32100 C CHANGES DOTTED RHYTHMS TO '1'S.
32200 736 IF(N.NE.'*')GO TO 236
32300 IAMP=-1
32400 INP(JD)=ISEMI
32600 GO TO 103
32700 236 CONTINUE
00100 C FOR ENTERING TEXT: 16, POS., STF., NT#., SIZE, RHYTHM≠0
00200 2114 FORMAT(72A1)
00300 21141 FORMAT(I,72A1)
00400 16 RC=R(4,1)
00500 IBEAM=-1
00600 RB=R(3,1)
00700 RNFLG=R(5,1)
00800 C RNFLG ≠0 CALLS NOTE NUM. SETUP
00900 161 IF(RC.EQ.0)RC=1.0
01000 CC TYPE 8005
01100 CC ACCEPT 2114,INP
01150 CALL TYPE
01200 DO 31 KN=72,1,-1
01300 31 IF(INP(KN).NE.IBLA)GO TO 33
01400 C KN=NUM OF CHARACTERS
01500 C DON'T END WITH '*' IN 'LETTERS' INPUT!!!!!!!!
01550 C , - . = ( ) + * : ; BLANK --THIS IS ORDER PAST ALPHAB.
01600 33 L=1
01700 RA=R(2,1)
01800 C RA= POSITION OF EACH LETTER
01900 C RB= NOTE #
02000 C RC= SIZE FACTOR
02050 CC IF(RNFLG.NE.0)CALL SETUP
02100 IZ=0
02200 368 IZ=IZ+1
02300 R(1,IZ)=16.
02400 R(2,IZ)=RA
02500 C NEXT IS A MAGIC NUMBER FOR SPACING LETTERS.
02600 Y=39.6*RSTJC
02700 26 RA=RA+Y*RC
02800 R(3,IZ)=STAFF
02900 R(4,IZ)=RB
03000 R(5,IZ)=RC
03100
03200 DO 364 JE=6,8
03300 Y=0
03400 DO 363 JD=1,4
03500 361 JC=INP(L)
03600 IF(JC.NE.'/')GO TO 365
03700 JC=JD
03800 DO 367 KA=JE,8
03900 X=.990
04000 DO 366 K=JC,4
04100 Y=Y+X
04200 366 X=X*100.0
04300 R(KA,IZ)=Y
04400 JC=1
04500 367 Y=0
04600 L=L+1
04700 C L=CHARACTER COUNTER
04800 GO TO 369
04900 365 DO 362 J=1,12
05000 IF(JC.NE.JALPHA(J))GO TO 362
05100 N=35+J
05200 GO TO 39
05300 362 CONTINUE
05400 38 N=10-('A'-INP(L))/536870912
05500 C MAGIC NUMBER TO FIND LETTERS
05600 IF(N.LT.10)N=N+7
05700 39 L=L+1
05900 C BLANK=99(=47)
06000 X=N
06100 IF(JD.EQ.2)X=X*100.
06200 IF(JD.EQ.4)X=X/100.
06300 IF(JD.EQ.1)X=X*10000.
06400 363 Y=Y+X
06500 364 R(JE,IZ)=Y
06600 369 IF(L.LT.KN)GO TO 368
06700
06800 INP(1)=0
06900 C SO IT WON'T FIND A COMMAND IN THE MAIN PROG.
07000 IF(RNFLG.NE.0)CALL SETLET
07100 GO TO 8024
07400 C PACKS 4 CHARS/WD, 3 WDS/ITEM. ORDER=[, - . = ( )] 000000.00
07500
07600 5016 IF(IAMP.GE.0)GO TO 1299
07700 IF(PARENS.NE.0)GO TO 3362
07800 C PARENS ARE STILL OPEN?
07900 GO TO 3013
08000 103 K=INP(ML)
08100
08200 C LAST SECTION
08300 IF(K.EQ.ISEMI)GO TO 1014
08600 C*********** MODE #?
08700 IF(K.NE.IBLA) GO TO 1899
08800 ML=ML+1
08900 GO TO 103
09000 1899 JA=0
09100 C MUST BE ZERO IN SCANR
09200 CALL SCANR
09300 IF(VX1.EQ.-99.)GO TO 4022
09400 IF(MODE.NE.2)GO TO 17
09500 C*********** MODE #?
09600 2017 IF(VX1.EQ.10000.)GO TO 17
09700 VX1=4./VX1
09800 IF(JJ.NE.1)GO TO 2014
09900 V(I)=VX1
10000 GO TO 114
10100 2014 DO 9006 L=2,JJ
10200 IF(VX(L).EQ.0)GO TO 17
10300 9006 VX1=4./VX(L)+VX1
10400 JJ=1
10500 17 V(I)=VX1
10600 IF(JJ.LE.1)GO TO 114
10700 IF(MODE.NE.1.OR.VX2.EQ.0)GO TO 171
10800 C JUMP IF RHY OR 'X 4' ETC.
10900 V(I)=-(VX1/100.+VX2/10000.)
11000 C PACKS 2 METER NUMS INTO ONE SLOT (-.1208 = 12/8)
11100 GO TO 114
11200 171 L=VX(JJ)-1
11300 X=V(I)
11400 NL=I+1
11500 I=L+I
11600 DO 1017 K=NL,I
11700 1017 V(K)=X
11800 C ADDS UP TOTAL OF NOTES IN SEQ.
11900 GO TO 114
12000 1014 V(I)=RB
12100 114 RB=V(I)
12200 I=I+1
12300 GO TO 5016
12400 4022 JC=VX2+.3
12500 JD=VX3-.5
12600 IF(JJ.EQ.2)JD=1
12700 C JC=HOW MANY TIMES, JD=HOW MANY NOTES
12800 DO 1005 K=1,JD
12900 NL=I+JC-1
13000 DO 2005 L=I,NL
13100 2005 V(L)=V(L-JC)
13200 1005 I=I+JC
13300 RB=V(NL)
13400 C RB SAVES DATA FOR SLASH REPEAT FEATURE.
13500 GO TO 5016
13600
13700 3013 IF(MODE.EQ.2.AND.I-1.NE.IRHY)GO TO 8015
13800 C WRONG NUMBER OF ITEMS
13900 V(I)=-99.
14100 IF(MODE.NE.1)GO TO 132
14200 131 CALL NOTES
14300 GO TO 8006
14400 132 CALL RHYTH
14500 CC IF(R1.EQ.50)GO TO 8024
14600 C =50 IS RHYTHM FOR TEXT
14650 IF(IREAD.EQ.0)CALL NUMB
14700 GO TO 8006
14800 C ACCENTS ARE IN BEAMS SUBROUTINE
14900 133 CALL BEAMS
15000 IF(MODE.EQ.5)GO TO 8024
15100 IF(MODE.EQ.3)IBEAM=0
15200 C FOR STEM NORMALIZATION
15300 GO TO 8006
15400 END
15500
15550 SUBROUTINE TYPE
15600 COMMON/ALF/INP(72),ML
15700 TYPE 8005
15800 ACCEPT 2114,INP
16000 2114 FORMAT(72A1)
16100 8005 FORMAT(' TYPE --'/)
16200 END